COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00011 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp))

(eval-when (compile eval)
	   (setq meter:meters ()))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo")
;;; (m "Foo" 3)
;;; (m "Foo" 3 (foo a b c))
;;; (mn "Foo" foo)
;;; (mn "Foo" foo 3)
;;; (mn "Foo" foo 3 (foo a b c))

(defmacro meter (function)
	  (cond ((and (boundp 'meter:meterp)
		      (not meter:meterp))
		 (meter:unprocess function))
		(t 
		 (let* ((name (cadr function))
			(array-name (implode (append (explode name) 
						     '(- a r r a y)))) 
			(comment-array-name (implode (append (explode name)
							     '(- c o m m e n t))))
			(init-name (implode (append (explode name)
						    '(- i n i t))))
			(meter:max -1)
			(meter:comments ()))
		       `(progn 'compile
			       (declare (array* (fixnum ,array-name 1)
						(notype ,comment-array-name 1)))
			       ,(meter:process array-name function)
			       ,@(progn
				  (let ((entry (assq name meter:meters)))
				       (cond (entry (rplaca (cdddr entry) meter:max))
					     (t 
					      (push 
					       `(,name ,array-name ,comment-array-name ,meter:max)
					       meter:meters))))
				  ())
			       (defun ,init-name () (fillarray ',array-name '(0)))
			       (array ,comment-array-name t ,(1+ meter:max))
			       (fillarray ',comment-array-name 
					  (quote ,(reverse 
						   (mapcar #'cadr
							   meter:comments))))
			       (array ,array-name fixnum ,(1+ meter:max))
			       (setq meter:meters ',meter:meters)
			       ',name))))) 

(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f))))
		     (result
		      (progn
		       (setq meter:max (1+ meter:max))
		       (push `(() ,(cadr f) 
				  . ,meter:max)
			     meter:comments)
		       `(store 
			 (,a ,meter:max) 
			 (+ ,inc (,a ,meter:max))))))
		    (cond (form
			   `(progn ,result ,(meter:process a form)))
			  (t result))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assq index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
		     (result
		      (cond (entry 
			     `(store (,a ,(cddr entry))
				     (+ ,inc (,a ,(cddr entry)))))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f) 
					      . ,meter:max)
				     meter:comments)
			       `(store 
				 (,a ,meter:max) 
				 (+ ,inc (,a ,meter:max)))))))
		    (cond (form
			   `(progn ,result ,(meter:process a form)))
			  (t result))))
	     (t `(,(meter:process a (car f))
		  . ,(meter:process a (cdr f))))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

(defun meter:report (&optional (name ()))
 (terpri)
 (princ '|Statistics|)
 (terpri)
 (do ((l (cond ((null name) meter:meters)
	       (t (let ((entry (assq name meter:meters)))
		       (cond (entry (ncons entry))
			     (t ())))))
	 (cdr l)))
     ((null l) t)
     (terpri)
     (princ '|Meter for: |)
     (princ (car (car l)))
     (terpri)
     (let ((ar1 (get (cadr (car l)) 'array))
	   (ar2 (get (caddr (car l)) 'array))
	   (max (cadddr (car l))))
	  (do ((n 0 (1+ n)))
	      ((> n max) (terpri))
	      (princ (arraycall t ar2 n))
	      (princ '| = |)
	      (princ (arraycall fixnum ar1 n))
	      (terpri)))))